home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / progjour / 1991 / 02 / f90examp.for < prev    next >
Text File  |  1991-02-10  |  6KB  |  171 lines
  1. *      The following Fortran 90 code listing fragments are from 
  2. *      Thomas M. Lahey's article entitled "Fortran 90 is Coming!"
  3.  
  4. *** LISTING 1
  5.        REAL, DIMENSION(:,:), ALLOCATABLE :: temps, pressures
  6.        ...
  7.        n = 16384            ! Try for arrays of 24*8192 elements
  8. 10     n = n/2              ! n too big, halve it
  9.        ALLOCATE ( temps(24, n), STAT=notice )
  10.        IF ( notice .NE. 0 ) GO TO 10    ! temps not allocated
  11.        ALLOCATE ( pressures(24, n), STAT=notice )
  12.        IF ( notice .NE. 0 ) THEN
  13.            DEALLOCATE ( temps );  GO TO 10
  14.        ENDIF
  15.  
  16. !  pressures and temps have been allocated 24 by n elements.
  17.        IF ( n << 1024 ) THEN
  18.            PRINT '(" Only able to allocate"I4," elements")', n
  19.            STOP "Quitting"
  20.        ENDIF
  21.        ...
  22.  
  23.  
  24. *** LISTING 2
  25.  
  26. !  pntr1 & pntr2 associate only with two-dimensional REAL arrays
  27.        COMMON /pointers/ pntr1, pntr2
  28.        REAL, POINTER, DIMENSION(:,:) ::  pntr1,  pntr2
  29.  
  30. !  array1 & array2 are descriptors that "know" they are unallocated
  31. !  TARGET is required since they will be associated with a pointer
  32.        REAL, TARGET, DIMENSION(:,:)  ::  array1, array2
  33.        ...
  34.        ALLOCATE ( array1(50,50), array2(70,90) )
  35.        pntr1 =>> array1;  pntr2 =>> array2  !POINTER ASSIGNMENTs
  36.        CALL s        ! if s declares COMMON /pointers/, then it can
  37.                      ! access array1 and array2
  38.        ...
  39.  
  40.  
  41. ***LISTING 3
  42.  
  43.        FUNCTION elements(string)            ! Count words
  44.        IMPLICIT NONE;         INTEGER i
  45.        CHARACTER*(*) string;  LOGICAL separator
  46.        TYPE inventory
  47.            INTEGER nwords, nletters, npunct, nblanks, nelse
  48.        END TYPE inventory
  49.        TYPE (inventory) elements
  50.  
  51. !  Initialize structure, INTRINSIC TRIM removes trailing blanks
  52.        elements%nwords = 0;  elements%nletters = 0
  53.        elements%npunct = 0;  elements%nelse = 0
  54.        elements%nblanks = LEN(string) - LEN( TRIM(string) )
  55.  
  56.        IF ( string == '' ) RETURN               ! All blanks
  57.        separator = .TRUE.                       ! To count words
  58.  
  59. block1:  DO  i = 1, LEN( TRIM(string) )  ! No trailing ' '
  60.                SELECT CASE ( string(i:i) )
  61.                   CASE ( ' ' )             ! Blank
  62.                       elements%nblanks = elements%nblanks +1
  63.                       separator = .TRUE.
  64.                   CASE (a:z, A:Z)          ! Letters
  65.                       elements%nletters = elements%nletters +1
  66.                       IF ( separator ) THEN    ! New word?
  67.                           nwords = nwords +1  ! Yes
  68.                           separator = .FALSE.
  69.                       ENDIF
  70.                   CASE ( '.', ',', ';' )        ! Punctuation
  71.                       separator = .TRUE.
  72.                       elements%npunct = elements%npunct +1
  73.                   CASE DEFAULT                 ! All others
  74.                       elements%nelse = elements%nelse +1
  75.                END SELECT
  76.            END DO  block1
  77.        END
  78.  
  79.  
  80. ***LISTING 4
  81.  
  82.        MODULE ISO_string
  83.  
  84. !  Derived-type dynamic-length CHAR item: POINTER to rank-one array
  85.        TYPE string        ! User defines DERIVED-TYPE STRINGs
  86.           PRIVATE         ! Component "chars" unavailable to user
  87.           CHARACTER, DIMENSION(:), POINTER  ::  chars
  88.        END TYPE string
  89.  
  90.        INTERFACE ASSIGNMENT(=)
  91.           MODULE PROCEDURE    ! MODULE SUBROUTINEs defined below
  92.       &   s_eqs_s,            ! CALLed if string = string parsed
  93.       &   s_eqs_c,            ! CALLed if string = char parsed
  94.       &   c_eqs_s             ! CALLed if char = string parsed
  95.        END INTERFACE
  96.  
  97.        INTERFACE OPERATOR(//)
  98.           MODULE PROCEDURE    ! MODULE FUNCTIONs defined later
  99.       &   s_concat_s,         ! Invoked if string // string parsed
  100.       &   s_concat_c,         ! Invoked if string // char parsed
  101.       &   c_concat_s          ! Invoked if char // string parsed
  102.        END INTERFACE
  103.  
  104. !  Note: The ISO MODULE defines relational operators
  105. !  Note: The ISO MODULE defines its INTRINSIC FUNCTIONs LEN, INDEX
  106. !  Note: The ISO MODULE defines type conversions for internal 
  107. use
  108. !      ...  A lot more code!
  109.        SUBROUTINE s_eqs_s(st, ss)! Compiler CALLs when
  110.                                  ! string = string is parsed
  111.        TYPE (string) INTENT(OUT)  ::  st
  112.        TYPE (string) INTENT(IN)   ::  ss
  113.        IF ( .NOT. ASSOCIATED(ss%chars) ) CALL error
  114.        IF ( ASSOCIATED(st%chars) ) THEN
  115.           IF ( ASSOCIATED(ss%chars, st%chars)   ) RETURN
  116.           NULLIFY (st%chars)
  117.        ENDIF
  118.        st%chars = ss%chars
  119.        END SUBROUTINE s_eqs_s
  120. !      ... A lot more code!
  121.        END MODULE ISO_string
  122.  
  123. !  Using the string MODULE
  124.        USE string               ! The MODULE
  125.        TYPE (string) s1, s2     ! MODULE has type definition
  126.        ...
  127.        s1 = 'abc def '          ! Trailing blank preserved, 
  128. s_eqs_c
  129.        s2 = 'ghi jkl mno'
  130.        ...
  131.        s1 = s2 // s1           ! // is overloaded operator, 
  132. compiler
  133.                                ! invokes function s_cat_s(s2,s1) 
  134. then
  135.                                ! CALL s_eqs_s(s1,string_temp)
  136.        PRINT *, s1             ! Compiler prints structure components
  137.        END
  138.  
  139.  
  140. ***LISTING 5
  141.  
  142.       SUBROUTINE sub
  143.       CALL s
  144.       PRINT *, i, j            ! i & j are known to internals
  145.  
  146.       CONTAINS                 ! Required, separates host & internals
  147.  
  148.       SUBROUTINE s
  149.       i = nj(5);    END        ! i not declared locally, must be host
  150.  
  151.       FUNCTION nj(k)
  152.       j = k+5;      END        ! j not declared locally, must be host
  153.  
  154.       END SUBROUTINE sub
  155.  
  156.  
  157. ***LISTING 6
  158.  
  159.        NAMELIST /study_params/ temp, pres, volume
  160.        REAL, PARAMETER  ::  n = 6.02252E23,  R = 0.0823
  161. 10     PRINT *, 'To terminate, enter both values as 0'
  162.        PRINT *, 'If not changing both params end with /, no ,'
  163.        PRINT *, 'Input: &study_params temp=value, pres=value/'
  164.        IF ( temp .EQ. 0  .AND. pres .EQ. 0 ) STOP 'All done'
  165.        READ  (*, NML=study_params)
  166.        volume = n*R*temp/pres        ! Remember:  PV = nRT
  167.        WRITE (*, NML=study_params)   ! Outputs: temp, pres, & volume
  168.        GO TO 10
  169.        END 
  170.  
  171.